home *** CD-ROM | disk | FTP | other *** search
/ Aminet 30 / Aminet 30 (1999)(Schatztruhe)[!][Apr 1999].iso / Aminet / gfx / misc / gnuplot-3.7src.lha / gnuplot-3.7src / gnuplot-3.7.lha / gnuplot-3.7 / vms.c < prev   
Encoding:
C/C++ Source or Header  |  1998-11-20  |  7.6 KB  |  257 lines
  1. #ifndef lint
  2. static char    *RCSid = "$Id: vms.c,v 1.5 1998/06/18 14:55:22 ddenholm Exp $";
  3. #endif
  4.  
  5. /* GNUPLOT - vms.c */
  6.  
  7. /*[
  8.  * Copyright 1986 - 1993, 1998   Thomas Williams, Colin Kelley
  9.  *
  10.  * Permission to use, copy, and distribute this software and its
  11.  * documentation for any purpose with or without fee is hereby granted,
  12.  * provided that the above copyright notice appear in all copies and
  13.  * that both that copyright notice and this permission notice appear
  14.  * in supporting documentation.
  15.  *
  16.  * Permission to modify the software is granted, but not the right to
  17.  * distribute the complete modified source code.  Modifications are to
  18.  * be distributed as patches to the released version.  Permission to
  19.  * distribute binaries produced by compiling modified sources is granted,
  20.  * provided you
  21.  *   1. distribute the corresponding source modifications from the
  22.  *    released version in the form of a patch file along with the binaries,
  23.  *   2. add special version identification to distinguish your version
  24.  *    in addition to the base release version number,
  25.  *   3. provide your name and address as the primary contact for the
  26.  *    support of your modified version, and
  27.  *   4. retain our contact information in regard to use of the base
  28.  *    software.
  29.  * Permission to distribute the released version of the source code along
  30.  * with corresponding source modifications in the form of a patch file is
  31.  * granted with same provisions 2 through 4 for binary distributions.
  32.  *
  33.  * This software is provided "as is" without express or implied warranty
  34.  * to the extent permitted by applicable law.
  35. ]*/
  36.  
  37. /* drop in popen() / pclose() for VMS
  38.  * (originally written by drd for port of perl to vms)
  39.  */
  40.  
  41. #include "plot.h"     /* for the prototypes */
  42. #include "stdfn.h"
  43.  
  44. static int something_in_this_file;
  45.  
  46. #ifdef PIPES
  47.  
  48. /* (to aid porting) - how are errors dealt with */
  49.  
  50. #define ERROR(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); }
  51. #define FATAL(msg) { fprintf(stderr, "%s\nFile %s line %d\n", msg, __FILE__, __LINE__); exit(EXIT_FAILURE); }
  52.  
  53.  
  54. #include <dvidef.h>
  55. #include <syidef.h>
  56. #include <jpidef.h>
  57. #include <ssdef.h>
  58. #include <descrip.h>
  59.  
  60. #ifdef __DECC             /* DECC does not automatically search */
  61. #include <lib$routines.h>
  62. #include <starlet.h>      /* for the sys$... routines */
  63. #endif  /* __DECC */
  64.  
  65. #ifndef EXIT_FAILURE                  /* not in older VAXC <stdlib.h> */
  66. #define EXIT_FAILURE 0x10000002       /* (STS$K_ERROR | STS$M_INHIB_MSG */
  67. #endif
  68.  
  69. #define _cksts(call) \
  70.   if (!(sts=(call))&1) FATAL("Internal error") else {}
  71.  
  72. static void
  73. create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
  74. {
  75.     static unsigned long int mbxbufsiz;
  76.         long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
  77.     unsigned long sts;  /* for _cksts */
  78.   
  79.   if (!mbxbufsiz) {
  80.     /*
  81.      * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
  82.      * preprocessor consant BUFSIZ from stdio.h as the size of the
  83.      * 'pipe' mailbox.
  84.      */
  85.  
  86.     _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
  87.     if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; 
  88.   }
  89.   _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
  90.  
  91.   _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
  92.   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
  93.  
  94. }  /* end of create_mbx() */
  95.  
  96. struct pipe_details
  97. {
  98.     struct pipe_details *next;
  99.     FILE *fp;
  100.     int pid;
  101.     unsigned long int completion;
  102. };
  103.  
  104. static struct pipe_details *open_pipes = NULL;
  105. static $DESCRIPTOR(nl_desc, "NL:");
  106. static int waitpid_asleep = 0;
  107.  
  108. static void
  109. popen_completion_ast(unsigned long int unused)
  110. {
  111.   if (waitpid_asleep) {
  112.     waitpid_asleep = 0;
  113.     sys$wake(0,0);
  114.   }
  115. }
  116.  
  117. FILE *
  118. popen(char *cmd, char *mode)
  119. {
  120.     static char mbxname[64];
  121.     unsigned short int chan;
  122.     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
  123.     struct pipe_details *info;
  124.     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
  125.                                       DSC$K_CLASS_S, mbxname},
  126.                             cmddsc = {0, DSC$K_DTYPE_T,
  127.                                       DSC$K_CLASS_S, 0};
  128.     unsigned long sts;                            
  129.  
  130.     if (!(info=malloc(sizeof(struct pipe_details))))
  131.     {
  132.         ERROR("Cannot malloc space");
  133.         return NULL;
  134.     }
  135.  
  136.     info->completion=0;  /* I assume this will remain 0 until terminates */
  137.         
  138.     /* create mailbox */
  139.     create_mbx(&chan,&namdsc);
  140.  
  141.     /* open a FILE* onto it */
  142.     info->fp=fopen(mbxname, mode);
  143.  
  144.     /* give up other channel onto it */
  145.     _cksts(sys$dassgn(chan));
  146.  
  147.     if (!info->fp)
  148.         return NULL;
  149.         
  150.     cmddsc.dsc$w_length=strlen(cmd);
  151.     cmddsc.dsc$a_pointer=cmd;
  152.  
  153.     if (strcmp(mode,"r")==0) {
  154.       _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
  155.                      0  /* name */, &info->pid, &info->completion,
  156.                      0, popen_completion_ast,0,0,0,0));
  157.     }
  158.     else {
  159.       _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
  160.                      0  /* name */, &info->pid, &info->completion));
  161.     }
  162.  
  163.     info->next=open_pipes;  /* prepend to list */
  164.     open_pipes=info;
  165.         
  166.     return info->fp;
  167. }
  168.  
  169. int pclose(FILE *fp)
  170. {
  171.     struct pipe_details *info, *last = NULL;
  172.     unsigned long int abort = SS$_TIMEOUT, retsts;
  173.     unsigned long sts;
  174.     
  175.     for (info = open_pipes; info != NULL; last = info, info = info->next)
  176.         if (info->fp == fp) break;
  177.  
  178.     if (info == NULL)
  179.       /* get here => no such pipe open */
  180.       FATAL("pclose() - no such pipe open ???");
  181.  
  182.     if (!info->completion) { /* Tap them gently on the shoulder . . .*/
  183.       _cksts(sys$forcex(&info->pid,0,&abort));
  184.       sleep(1);
  185.     }
  186.     if (!info->completion)  /* We tried to be nice . . . */
  187.       _cksts(sys$delprc(&info->pid));
  188.     
  189.     fclose(info->fp);
  190.     /* remove from list of open pipes */
  191.     if (last) last->next = info->next;
  192.     else open_pipes = info->next;
  193.     retsts = info->completion;
  194.     free(info);
  195.  
  196.     return retsts;
  197. }  /* end of pclose() */
  198.  
  199.  
  200. /* sort-of waitpid; use only with popen() */
  201. /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
  202. unsigned long int
  203. waitpid(unsigned long int pid, int *statusp, int flags)
  204. {
  205.     struct pipe_details *info;
  206.     unsigned long int abort = SS$_TIMEOUT;
  207.     unsigned long sts;
  208.     
  209.     for (info = open_pipes; info != NULL; info = info->next)
  210.         if (info->pid == pid) break;
  211.  
  212.     if (info != NULL) {  /* we know about this child */
  213.       while (!info->completion) {
  214.         waitpid_asleep = 1;
  215.         sys$hiber();
  216.       }
  217.  
  218.       *statusp = info->completion;
  219.       return pid;
  220.     }
  221.     else {  /* we haven't heard of this child */
  222.       $DESCRIPTOR(intdsc,"0 00:00:01");
  223.       unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
  224.       unsigned long int interval[2];
  225.  
  226.       _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
  227.       _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
  228.       if (ownerpid != mypid)
  229.         FATAL("pid not a child");
  230.  
  231.       _cksts(sys$bintim(&intdsc,interval));
  232.       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
  233.         _cksts(sys$schdwk(0,0,interval,0));
  234.         _cksts(sys$hiber());
  235.       }
  236.       _cksts(sts);
  237.  
  238.       /* There's no easy way to find the termination status a child we're
  239.        * not aware of beforehand.  If we're really interested in the future,
  240.        * we can go looking for a termination mailbox, or chase after the
  241.        * accounting record for the process.
  242.        */
  243.       *statusp = 0;
  244.       return pid;
  245.     }
  246.                     
  247. }  /* end of waitpid() */
  248.  
  249. #endif /* PIPES */
  250.  
  251.  
  252. /* vax c doesn't come with strftime - watch out for redefn of RCSid */
  253. #ifdef VAXCRTL
  254. # define RCSid RCSid2
  255. # include "strftime.c"
  256. #endif
  257.